home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
t3_1
/
encorsrc.lha
/
encore_sources
/
sys
/
n32lap.t
< prev
next >
Wrap
Text File
|
1988-05-02
|
15KB
|
395 lines
(herald n32lap ;86/12/19
(env tsys))
;;; Copyright (c) 1985 Yale University
;;; Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
;;; This material was developed by the T Project at the Yale University Computer
;;; Science Department. Permission to copy this software, to redistribute it,
;;; and to use it for any purpose is granted, subject to the following restric-
;;; tions and understandings.
;;; 1. Any copy made of this software must include this copyright notice in full.
;;; 2. Users of this software agree to make their best efforts (a) to return
;;; to the T Project at Yale any improvements or extensions that they make,
;;; so that these may be included in future releases; and (b) to inform
;;; the T Project of noteworthy uses of this software.
;;; 3. All materials developed as a consequence of the use of this software
;;; shall duly acknowledge such use, in accordance with the usual standards
;;; of acknowledging credit in academic research.
;;; 4. Yale has made no warrantee or representation that the operation of
;;; this software will be error-free, and Yale is under no obligation to
;;; provide any services, by way of maintenance, update, or otherwise.
;;; 5. In conjunction with products arising from the use of this material,
;;; there shall be no use of the name of the Yale University nor of any
;;; adaptation thereof in any advertising, promotional, or sales literature
;;; without prior written consent from Yale in each case.
;;;
;;; lap code is of the form (lap free-vars . code)
;;; lap templates are (lap-template (pointer scratch nargs) . code)
(define local-processor ;86/12/19
(lambda ()
(object nil
((processor-type self) 'NS32000)
((print-type-string self) "Processor"))))
(define (template-definer-vcell-offset template)
(let ((template (if (fixnum-equal? (mref-integer template -2)
n32-jump-absolute-hack)
(extend-elt template 1)
template)))
(let ((offset (fixnum-ashr (mref-16-u template -12) 3)))
(if (fx= offset 0)
nil
(fx- offset 1)))))
(define (invoke-stack-continuation frame vals) ;86/12/19
(lap (return apply)
(subi d ($ 2) A1)
(lpri d SP A1)
(cmpi d A2 (d@r nil-reg slink/nil-car))
(j= no-values)
(cmpi d (d@r A2 -3) (d@r nil-reg slink/nil-car))
(jn= many-values)
(movi d (d@r A2 1) A1)
(movi d ($ -2) NARGS)
(movi d (@r sp) tp)
(jump (@r tp))
no-values
(movi d ($ -1) NARGS)
(movi d (@r sp) tp)
(jump (@r tp))
many-values
(movi d (d@r P (static 'return)) A1)
(movi d (d@r a1 2) a1)
(movi d (d@r P (static 'apply)) P)
(movi d (d@r p 2) p)
(movi d ($ 3) NARGS)
(movi d (d@r p -2) tp)
(jump (@r tp))))
(define (invoke-continuation sp stack vals base-state current-state) ;86/12/20
(lap (rewind-state-and-continue)
(ori b ($ #b01000000) (d@r TASK (fx+ task/critical-count 3))) ; ignore int's
(lpri d SP A1) ; set new continuation
(movi d (d@r TASK task/stack) S0) ; limit at stack base
(addi d ($ 2) A2) ; start at first word of stack in heap
(jbr copy-stack-test)
copy-stack-loop
(movi d (@r A2) (@r A1))
(addi d ($ 4) a2) ; can save an instruction with index mode
(addi d ($ 4) a1)
copy-stack-test
(cmpi d S0 A1)
(j>= copy-stack-loop)
(bici b ($ #b1000000) (d@r TASK (fx+ task/critical-count 3)))
(movi d (d@r TASK 12) A1)
(movi d (d@r TASK 16) A2)
(movi d (d@r P (static 'rewind-state-and-continue)) P)
(movi d (d@r p 2) p)
(movi d ($ 4) NARGS)
(movi d (d@r p -2) tp)
(jump (@r tp))))
;;; (FIXNUM-HOWLONG n)
;;; Returns the number of bits in N's binary representation.
;;; Horrible name, after MACLISP function HAULONG.
;;; Similar to a binary search. Repeatedly divide the bit string in half.
;;; If the upper half has any bits on, count all the bits in the lower
;;; half and throw them away.
(define (fixnum-howlong num) ;86/12/20
(lap ()
(cmpi d A1 ($ 0))
(j>= howlong0)
(movi d ($ (fx* 30 4)) A1) ; negative fixnum, length is 30.
(jbr howlong_exit)
howlong0
(movi d A1 S0)
(lshi d ($ -2) S0) ; S0 holds number
(movi d ($ 0) A1) ; A1 holds result
(cmpi d S0 ($ #x8000))
(j< howlong1)
(addi d ($ (fx* 16 4)) A1) ; add 16 to result
(ashi d ($ -16) S0)
howlong1
(cmpi d S0 ($ #x80))
(j< howlong2)
(addi d ($ (fx* 8 4)) A1)
(ashi d ($ -8) S0)
howlong2
(cmpi d S0 ($ #x8))
(j< howlong3)
(addi d ($ (fx* 4 4)) A1)
(ashi d ($ -4) S0)
howlong3
(cmpi d S0 ($ #x2))
(j< howlong4)
(addi d ($ (fx* 2 4)) A1)
(ashi d ($ -2) S0)
howlong4
(cmpi d S0 ($ #x1))
(j< howlong_exit)
(addi d ($ (fx* 1 4)) A1)
howlong_exit
(movi d ($ -2) NARGS)
(movi d (@r sp) tp)
(jump (@r tp))))
(define (*set x y) ;86/12/20
(lap ()
(movi d A2 (d@r a1 2))
(cmpi b ($ 0) (@r a1))
(j= foo-set)
(movi d a1 (d@r TASK task/extra-pointer))
(jsr (*d@r nil-reg slink/set))
foo-set
(movi d ($ -2) NARGS)
(movi d (@r sp) tp)
(jump (@r tp))))
(define (apply-traced-operation proc . args) ;86/12/20
(lap (*traced-op-template*)
(movi d (d@r P (static '*traced-op-template*)) TP)
(movi d (d@r tp 2) tp)
(movi d ($ 0) (d@r TASK task/extra-scratch))
(jbr entry)))
;;; Remember that APPLY is nary; only the last argument must be a list.
;;; ALG:
;;; - Move all arguments down one register (e.g. A2 must move to A1).
;;; This requires special case code for A1, A2, A3, then a loop for
;;; the argument registers in the task block.
;;; - The last argument is actually a list of the remaining arguments; move
;;; the elements to argument registers.
;;; - Call the procedure.
(define (apply proc . args) ;86/12/20
(lap (apply-too-many-args)
(movi d ($ 1) (d@r TASK task/extra-scratch))
entry
(subi d ($ 1) NARGS) ;; shift proc out
(movi d P (tos)) ;; save environment
(movi d A1 (tos)) ;; first arg is proc (save it)
(cmpi d ($ 1) NARGS) ;; no args to proc
(j= apply-done)
(subi d ($ 1) NARGS)
(cmpi d ($ 1) NARGS)
(jn= next1)
(movi d A2 AN)
(jbr apply-one-arg)
next1
(cmpi d ($ 2) NARGS)
(jn= next2)
(movi d A2 A1)
(movi d A3 AN)
(jbr apply-two-args)
next2
(cmpi d ($ 3) NARGS)
(jn= next3)
(movi d A2 A1)
(movi d A3 A2)
(movi d (d@r TASK 12) AN) ;; first argument temp
(jbr apply-three-args)
next3
(movi d A2 A1)
(movi d A3 A2)
(movi d (d@r TASK 12) A3) ;; first argument temp
(movi d NARGS S0)
(subi d ($ 4) S0) ;; S0 counts down to 0
(addr (d@r TASK 16) P) ;; set up P to point into rest vector
;; first 3 temps reserved, 1 done already
(jbr apply-shift-test)
apply-shift-loop-top
(movi d (@r P) (d@r P -4))
(subi d ($ 1) S0)
(addi d ($ 4) P)
apply-shift-test
(cmpi d ($ 0) S0)
(jn= apply-shift-loop-top)
(movi d (@r P) AN)
(subi d ($ 4) P)
(jbr apply-spread-loop)
apply-one-arg
(cmpi d AN (d@r nil-reg slink/nil-car))
(j= apply-done)
(movi d (d@r AN 1) A1)
(addi d ($ 1) NARGS)
(movi d (d@r AN -3) AN)
apply-two-args
(cmpi d AN (d@r nil-reg slink/nil-car))
(j= apply-done)
(movi d (d@r AN 1) A2)
(addi d ($ 1) NARGS)
(movi d (d@r AN -3) AN)
apply-three-args
(cmpi d AN (d@r nil-reg slink/nil-car))
(j= apply-done)
(movi d (d@r AN 1) A3)
(addi d ($ 1) NARGS)
(movi d (d@r AN -3) AN)
(addr (d@r TASK 12) P)
apply-spread-loop
(cmpi d AN (d@r nil-reg slink/nil-car))
(j= apply-done)
(movi d (d@r AN 1) (@r P))
(addi d ($ 1) NARGS)
(cmpi d NARGS ($ (+ *pointer-temps* 1)))
(j> too-many)
(addi d ($ 4) P)
(movi d (d@r AN -3) AN)
(jbr apply-spread-loop)
too-many
(movi d (tos) A1) ; procedure is argument
(movi d (tos) P)
(movi d ($ 2) NARGS)
(movi d (d@r P (static 'apply-too-many-args)) P)
(movi d (d@r p 2) p)
(movi d (d@r p -2) tp)
(jump (@r tp))
apply-done
(movi d (tos) P) ; restore procedure
(adjspi b ($ -4)) ; get rid of environment
(cmpi d ($ 0) (d@r TASK task/extra-scratch))
(j= traced)
(movi d (d@r p -2) tp)
(jump (@r tp))
traced
(jump (@r TP))))
;;; n32 code uses only 2 scratch registers (S0 and NARGS)
(define (string-hash string) ;86/12/20
;; string in A1
(lap ()
;; enter critical gc
(movi d (d@r A1 offset/string-text) A3);; raw string text in A3
(addi d (d@r A1 offset/string-base) A3)
(addi d ($ 2) A3)
hash
(movi d (d@r A1 -2) S0) ;; string length in S0, will count
(ashi d ($ -8) S0) ;; down to 0
(movi d ($ 0) NARGS) ;; hash value so far in NARGS
(jump (label hash-test))
hash-loop
(roti d ($ 1) NARGS) ;++ change to 3 later
(addi b (@r A3) NARGS)
(addi d ($ 1) A3)
hash-test
(subi d ($ 1) S0)
(cmpi d S0 ($ 0))
(j>= hash-loop) ;; loop if count >= 0
;; exit critical gc
(movi d NARGS S0) ;; re-use S0 as temp
(roti d ($ 16) S0)
(xori d S0 NARGS)
(bici d ($ #x80000003) NARGS) ;; positive-fixnumize
(movi d NARGS A1)
(movi d ($ -2) NARGS) ;; NARGS back to standard usage
(movi d (@r sp) tp)
(jump (@r tp))))
;;; magic frame is next-state
;;; winder
;;; previous-state
;;; unwinder
;;; *magic-frame-template*
(define (push-magic-frame unwinder stuff wind) ;86/12/20
(lap (*magic-frame-template* bind-internal)
(movi d (d@r TASK task/dynamic-state) AN)
(spri d nil-reg (tos)) ; next state
(movi d A3 (tos)) ; winder
(movi d AN (tos)) ; previous state
(movi d A1 (tos)) ; unwinder
(movi d (d@r P (static '*magic-frame-template*)) a3)
(movi d (d@r a3 2) (tos))
(addr (d@r SP 2) A1) ; first arg is the magic frame
(cmpi d AN (d@r nil-reg slink/nil-car)) ; is there a previous state?
(j= magic-frame-exit)
(movi d A1 (d@r AN 14)) ; set next slot to this magic frame
magic-frame-exit
(movi d (d@r P (static 'bind-internal)) P) ; second arg is stuff
(movi d (d@r p 2) p)
(movi d ($ 3) NARGS)
(movi d (d@r p -2) tp)
(jump (@r tp))))
(define (make-structure-template size) ;86/12/20
(lap (*structure-template* *stype-template*)
(movi d (d@r P (static '*stype-template*)) AN)
(movi d (d@r an 2) an)
(movi d ($ 40) S0) ; 10 slots
(jsr (*d@r nil-reg slink/make-extend))
(movi w ($ 32) (d@r AN 26)) ; offset within closure
(movi b ($ 0) (d@r AN 28)) ; 0 scratch slots
(movi d A1 S0)
(ashi d ($ -2) S0) ; pointer slots
(movi b S0 (d@r AN 29))
(movi w ($ header/template) (d@r AN 30))
(movi w ($ N32-JUMP-ABSOLUTE) (d@r AN 32))
(movi d ($ slink/cit-hack) (d@r AN 34))
(movi d (d@r P (static '*structure-template*)) p)
(movi d (d@r p 2) (d@r AN 38)) ; auxilliary template
(addr (d@r AN 32) A1) ; return template
(movi d AN A2) ; and stype
(movi d ($ -3) NARGS) ; return two values
(movi d (@r sp) tp)
(jump (@r tp))))
;;; Floating point bit fields.
;;; <n,s> means bit field of length s beginning at bit n of the first
;;; WORD (not longword)
;;; sign exponent MSB fraction
;;; Apollo IEEE flonum <15,1> <4,11> hidden <0,4>+next 3 words
;;; VAX11 flonum (D) <15,1> <7,8> hidden <0,7>+next 3 words
;;; Apollo IEEE flonum - binary point follows hidden MSB, 53 bits of
;;; precision, if hidden bit is included
;;; VAX11 flonum (D) - binary point precedes hidden MSB, 56 bits of
;;; precision, if hidden bit is included
(define-constant %%d-ieee-size 53)
(define-constant %%d-ieee-excess 1023)
;;; <n,s> means bit field of length s beginning at bit n of the first
;;; WORD (not longword)
;;; sign exponent MSB fraction
;;; IEEE flonum <15,1> <4,11> hidden <0,4>+next 3 words
;;; VAX11 flonum (D) <15,1> <7,8> hidden <0,7>+next 3 words
(define (integer-decode-float x) ; IEEE version
(let ((a (mref-16-u x 6)))
(return (if (fl<= 0.0 x) 1 -1)
(+ (mref-16-u x 0)
(%ash (+ (mref-16-u x 2)
(%ash (fx+ (mref-16-u x 4)
(fixnum-ashl (fx+ (fixnum-bit-field a 0 4)
16)
16))
16))
16))
(fx- (fixnum-bit-field a 4 11) (fx+ 1024 51)))))
(define (integer-encode-float sign m e)
(let ((float (make-flonum)))
(receive (sign mantissa exponent)
(normalize-float-parts sign
m
e
%%d-ieee-size
%%d-ieee-excess
t)
(set (mref-16-u float 6) (fx+ (fixnum-ashl sign 15)
(fx+ (fixnum-ashl exponent 4)
(bignum-bit-field mantissa 48 4))))
(set (mref-16-u float 4) (bignum-bit-field mantissa 32 16))
(set (mref-16-u float 2) (bignum-bit-field mantissa 16 16))
(set (mref-16-u float 0) (bignum-bit-field mantissa 0 16))
float)))